Visual Basic 4 Database How-To/Visual Basic 4 Database - How-to (The Waite Group)(1995).iso/tbldata.fr_/tbldata.fr

Text File | 1995-07-05 | 9KB | 312 lines

VERSION 4.00
Begin VB.Form Form1
   BackColor       =   &H00C0C0C0&
   Caption         =   "Table Status"
   ClientHeight    =   4095
   ClientLeft      =   1470
   ClientTop       =   2610
   ClientWidth     =   4440
   BeginProperty Font
      name            =   "MS Sans Serif"
      charset         =   0
      weight          =   700
      size            =   8.25
      underline       =   0   'False
      italic          =   0   'False
      strikethrough   =   0   'False
   EndProperty
   Height          =   4500
   Left            =   1410
   LinkTopic       =   "Form1"
   ScaleHeight     =   4095
   ScaleWidth      =   4440
   Top             =   2265
   Width           =   4560
   Begin VB.CommandButton cmdChangeFile
      Caption         =   "Change &File"
      Height          =   555
      Left            =   600
      TabIndex        =   8
      Top             =   3240
      Width           =   1335
   End
   Begin VB.CommandButton cmdExit
      Cancel          =   -1  'True
      Caption         =   "Exit"
      Height          =   555
      Left            =   2400
      TabIndex        =   7
      Top             =   3240
      Width           =   1335
   End
   Begin VB.ListBox List1
      Height          =   1230
      Left            =   540
      Sorted          =   -1  'True
      TabIndex        =   0
      Top             =   300
      Width           =   3315
   End
   Begin MSComDlg.CommonDialog CommonDialog1
      Left            =   60
      Top             =   3240
      _Version        =   65536
      _ExtentX        =   847
      _ExtentY        =   847
      _StockProps     =   0
      CancelError     =   -1  'True
      DefaultExt      =   "MDB"
      DialogTitle     =   "Database File"
      FileName        =   "*.MDB"
      Filter          =   "*.MDB"
   End
   Begin VB.Label lblRecords
      Alignment       =   2  'Center
      BorderStyle     =   1  'Fixed Single
      BeginProperty Font
         name            =   "MS Sans Serif"
         charset         =   0
         weight          =   400
         size            =   8.25
         underline       =   0   'False
         italic          =   0   'False
         strikethrough   =   0   'False
      EndProperty
      Height          =   255
      Left            =   1740
      TabIndex        =   6
      Top             =   2760
      Width           =   1095
   End
   Begin VB.Label lblModified
      BorderStyle     =   1  'Fixed Single
      BeginProperty Font
         name            =   "MS Sans Serif"
         charset         =   0
         weight          =   400
         size            =   8.25
         underline       =   0   'False
         italic          =   0   'False
         strikethrough   =   0   'False
      EndProperty
      Height          =   255
      Left            =   1740
      TabIndex        =   5
      Top             =   2400
      Width           =   1935
   End
   Begin VB.Label lblCreated
      BorderStyle     =   1  'Fixed Single
      BeginProperty Font
         name            =   "MS Sans Serif"
         charset         =   0
         weight          =   400
         size            =   8.25
         underline       =   0   'False
         italic          =   0   'False
         strikethrough   =   0   'False
      EndProperty
      Height          =   255
      Left            =   1740
      TabIndex        =   4
      Top             =   2040
      Width           =   1935
   End
   Begin VB.Label Label3
      AutoSize        =   -1  'True
      BackColor       =   &H00C0C0C0&
      Caption         =   "Records:"
      Height          =   195
      Left            =   840
      TabIndex        =   3
      Top             =   2760
      Width           =   780
   End
   Begin VB.Label Label2
      AutoSize        =   -1  'True
      BackColor       =   &H00C0C0C0&
      Caption         =   "Last Modified:"
      Height          =   195
      Left            =   360
      TabIndex        =   2
      Top             =   2400
      Width           =   1215
   End
   Begin VB.Label Label1
      AutoSize        =   -1  'True
      BackColor       =   &H00C0C0C0&
      Caption         =   "Created:"
      Height          =   195
      Left            =   840
      TabIndex        =   1
      Top             =   2040
      Width           =   735
   End
End
Attribute VB_Name = "Form1"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit

' This collection is used by several different routines, so declare it
' at form level.

Private descripsCollection As New Collection
Private Sub Form_Load()

    ' Get the user's initial database selection and retrieve its table
    ' definition information.

    GetDatabase

End Sub
Private Sub GetDatabase()

    ' Get a database selection from the user, retrieve its non-system
    ' table definitions, and list the tables in the list box.

    Dim db As DATABASE
    Dim defs As TableDefs
    Dim i As Integer
    Dim descrip As clsTableStatus
    Dim databaseName As String

    ' Set up the error handler for the common dialog.

    On Error GoTo NoDatabaseError

    ' Display the common dialog box so the user can select a database.

    CommonDialog1.Action = 1

    ' Set up the error handler for the remaining code in the procedure.

    On Error GoTo GetDatabaseError

    ' Set the database name to the database file chosen by the user in the common
    ' dialog.

    databaseName = CommonDialog1.filename

    ' Display the hourglass.

    Screen.MousePointer = 11

    ' Open the database for shared, read-only access.

    Set db = DBEngine.Workspaces(0).OpenDatabase(databaseName, False, True)

    ' Set the TableDefs variable to the table definitions collection of
    ' this database.

    Set defs = db.TableDefs

    ' Cycle through the table definitions in the collection. If the
    ' if the definition is a system object (its name starts with MSys*),
    ' skip it. Otherwise, create a new clsTableStatus object.

    For i = 0 To defs.Count - 1
        If Left$(defs(i).Name, 4) <> "MSys" Then
            Set descrip = New clsTableStatus

            ' Get the desired information from the table definition and
            ' set the properties of the clsTableStatus object.

            descrip.ExtractStatusData defs(i)

            ' Add the object to the Table Status collection.

            descripsCollection.Add descrip

        End If
    Next i

    ' WeÆre through with the database, so close it.

    db.Close

    ' Cycle through the collection, adding the name of each table to
    ' the list box. Set each list entry's ItemData to the position
    ' of the object within the collection to facilitate retrieval of
    ' object when the user selects the item.

    For i = 1 To descripsCollection.Count
        Set descrip = descripsCollection.Item(i)
        list1.AddItem descrip.Name
        list1.ItemData(list1.NewIndex) = i
    Next i

    ' Restore the default cursor.

    Screen.MousePointer = 0

Exit Sub

NoDatabaseError:

    ' The user clicked Cancel in the File Open dialog box, so just abort
    ' the program.

End

GetDatabaseError:

    ' Restore the default cursor.

    Screen.MousePointer = 0

    ' Display the error message and then abort.

    MsgBox Error(Err)

End
End Sub
Private Sub list1_Click()
    Dim descrip As clsTableStatus
    Dim pos As Integer

    ' Get the selected table's position within the Table Status collection
    ' from the List Box ItemData property.

    pos = list1.ItemData(list1.ListIndex)

    ' Retrieve the indicated object from the collection and set the object
    ' variable to it.

    Set descrip = descripsCollection.Item(pos)

    ' Fill the boxes on the form with the information about the table
    ' definition, using the properties of the retrieved object.

    lblCreated = Format$(descrip.WhenCreated, "General Date")
    lblModified = Format$(descrip.WhenModified, "General Date")
    lblRecords = descrip.NumRecords
End Sub
Private Sub cmdChangeFile_Click()

    ' Get another database name from the user and retrieve table definitions
    ' for it.

    ' Clear the list box and text boxes

    list1.Clear
    lblCreated = ""
    lblModified = ""
    lblRecords = ""

    ' Clear out the collection.

    Do While descripsCollection.Count > 0
        descripsCollection.Remove (1)
    Loop

    CommonDialog1.filename = "*.MDB"
    GetDatabase

End Sub
Private Sub cmdExit_Click()
    End
End Sub